home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / tool+ / TimeManager < prev    next >
Text File  |  1993-05-18  |  3KB  |  95 lines
  1. \ Revised Time manager...used for any system >6.0.3 - assumes register A1
  2. \  contains address of record at proc call
  3. \    5/18/93    rfl    revised for new gestalt of version 3.64
  4.  
  5. \ Read IMIV for a description of what this might be used for..care must
  6. \ be taken not to move memory, rely on unlocked handles, etc.
  7. \ Remember to remove tasks prior to exiting the application.
  8.  
  9. create Tinstall  ( ptr -- result) popA0 " InsTime"  asmcall pushd0 next,
  10. create Tremove   ( ptr -- result) popA0 " rmvTime"  asmcall pushd0 next,
  11. create Tprime    ( len ptr -- result) popD0 popA0 " primeTime" asmcall pushd0 next,
  12.  
  13.  
  14. :CLASS timeTask <super object
  15.  
  16.     int            microseconds    \ true if delay in microseconds
  17.     var            myProc            \ myProc in relative address, will move on install
  18.     var            tmDelay
  19.  
  20.     var            qlink            \ setup extended record, even though this is revised class
  21.     int            qtype
  22.     var            tmAddr
  23.     var            tmCount
  24.  
  25.   :M init: ( 'cfaProc --) >body put: myProc ;M
  26.  
  27.   :M microseconds: ( b --) put: microseconds ;M
  28.  
  29. \ once installed, and then removed, you may reInstall using this method
  30.   :M reInstall: ( --) get: myProc +base put: tmAddr
  31.     clear: qType clear: qLink clear: tmCount
  32.     abs: qlink  Tinstall abort" can't install" ;M
  33.  
  34. \ Use this method as the first thing...It loads up the record with values
  35.   :M install: ( -- ) get: myProc body> initProc reInstall: self ;M
  36.  
  37. \ To remove the task from the queue
  38.   :M remove: ( --) abs: qlink  Tremove abort" can't remove" ;M
  39.  
  40. \ positive value is milliseconds, negative value is microseconds
  41.   :M setDelay: ( n --) get: microseconds IF negate THEN put: tmDelay ;M
  42.  
  43.   :M getDelay: ( -- n) get: tmDelay get: microseconds IF negate THEN ;M
  44.  
  45. \ start the task...it doesn't repeat, but must be restarted for continuous operation
  46.   :M go: abs: qlink get: tmDelay Tprime abort" can't start" ;M
  47.  
  48.   :M start: go: self ;M
  49.  
  50.   :M stop: remove: self ;M
  51.  
  52. \ return time remaining during countdown
  53.   :M time: ( -- microseconds) get: tmCount 20 * ;M
  54.  
  55. \ return time remaining after task has been stopped or executed
  56.   :M remaining: ( -- microseconds) get: tmCount negate ;M
  57.  
  58. \ return time elapsed after task has been stopped or executed
  59.   :M elapsed: ( -- microsecs)  get: tmCount get: tmDelay
  60.         get: microseconds
  61.         IF - ELSE -1000 * - THEN ;M
  62.  
  63.   :M on: ( --b) 'type sysv (gestalt) 0=        \ check if revised TM
  64.         IF $ 603 >=
  65.             IF get: qType $ 8000 and
  66.                 IF true ELSE false THEN
  67.             ELSE ." not supported
  68.             THEN
  69.         ELSE ." not supported"
  70.         THEN ;M
  71.  
  72.   :M pause: stop: self ;M
  73. \ continue counting after a pause...will count so that timer will run for original delay
  74.   :M resume: remaining: self get: microseconds not
  75.         IF 1000 / THEN setDelay: self reinstall: self go: self ;M
  76.  
  77. ;CLASS
  78.  
  79. \ procedure is to install a TprocWord, set the delay when the TprocWord should execute,
  80. \  and when you want to start timing, say go:
  81. \ When you're completely done, just remove:
  82.  
  83. \ rect suz
  84. \ 100 100 200 200 put: suz
  85. \ 
  86. \ timeTask painter
  87. \ :proc paintit pushPort set: fwind  paint: suz  popPort ;proc
  88. \ 5000 setdelay: painter
  89. \ 
  90. \ 'c paintit init: painter
  91. \ install: painter
  92. \ go: painter
  93.  
  94.  
  95.